perm filename HOMER.F4[P11,LCS]1 blob sn#589308 filedate 1981-05-26 generic text, type T, neo UTF8
C***** HOMER, PLACE
C****** FOR 'HOMING' OF BEAMS, SLURS, AND CHORD NOTES ***********
        SUBROUTINE HOMER 
        COMMON /STF/RSTFAC(8),RSTJ2
	 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /POSI/STFF(8),JJ2,POS 
        COMMON /XRN/RN(1) /PTR/PWDS(2) /LIMIT/LIM,ITEM,L,I,IX    
	1 /RMOD/RMODE2,RSET4,IBEAM,NOSET,STEM,STUP,NTC,ENDP,RAD,RDD
        COMMON/ALF/QQ(3),K,RA,RB,N,RG,M,X,RE,RF,A,B,DISX,INP(58) 
        EQUIVALENCE (R3,RJQ(1)),(R6,RJQ(4)),(J11,JQ(9))
	1,(R7,RJQ(5)),(R9,RJQ(7)),(R11,RJQ(9)),(R13,RJQ(11))
	1,(J10,JQ(8)),(R8,RJQ(6)),(J7,JQ(5)) 
      IF(JA.EQ.6)GO TO 9    
        IF(R13.NE.0)GO TO 10  
C  FOR GENL HOMING; WORDS;  BEAMS;  (STEMS HOMING IN HOMX.F4)    
C  2.44 = WIDTH OF NOTE -- NEEDED BECAUSE OF DIFF. STEM DIRECTIONS.   
     
	CALL HOMX
	RETURN
9      IF(J11.LT.0)RETURN
C    IF P11=-1 NO HOMING 
       JX=IABS(J7)/10    
C  JX= STEM DIR. OF BEAM 
10    IF(R11.EQ.0)R11=2.9
        IZ=0   
CC110    RC=0    
CC     IF(JA.EQ.5)RC=-1. 
       DO 361 K=1,ITEM   
         IF(FINDIT(K).LT.0)GO TO 361    
C  SKIPS NOTES ON WRONG LINE  
         RDD=RN(L+3) 
C  L IS IN COMMON   
       A=RDD    
       JK=RN(L+5)   
       JK=JK/10
C /10=NOTE'S STEM DIRECTION   
       IF(JA.NE.6)GO TO 177   
        IF(JK.EQ.0)GO TO 361  
       IF(JK.EQ.JX)GO TO 377  
C  ARE STEM DIR,S SAME?   YES, JUMP
       IF(RN(L).LT.8.)GO TO 2377   
       IF(RN(L+10).NE.0)GO TO 1377 
2377   A=(R4+R5)/2. 
       A=A-RN(L+4)  
C AVERAGE HEIGHT OF BEAM LESS HEIGHT OF NOTE  
       IF(JK.NE.1)A=-A   
C IF NOTE STEM DOWN, REVERSE SIGN  
       IF(A.LE.8.)GO TO 377   
C  IF DIFF. IS LESS THAN 8 DON'T HOOK BEAM TO STEM.    
1377   B=2.44*RSTJ2 
C DISX IS NOTE WIDTH( CURRENTLY =2.44)  
       NN=IABS(J4)  
       IF(NN.GE.80.AND.NN.LT.180)A=A*.6 
C IS IT A MINI?
       IF(JK.NE.1)B=-B   
C JK+=STEM UP, -=DOWN    
       RDD=RDD+B 
C ADD OR SUB. NOTE WIDTH FROM NOTE POS. 
        GO TO 177   
377     IF(JK.NE.JX)GO TO 361 
177    IF(PLACE(R3).GT.0)GO TO 1461
C  DO NEXT IF HOMING SLUR
       IF(JA.NE.5)GO TO 461   
C ALSO CHECK FOR P6 (RT. END OF SLUR)   
       IF(PLACE(R6).LT.0)GO TO 461 
       JT=3    
       NX=4    
C POINT TO R6  OR R5
       GO TO 2 
1461   NX=1    
	JT=2
C POINT TO R3  OR R4
       IZ=-1   
2      IF(RN(L+6).LT.10.)GO TO 1   
CC     IF(JK.EQ.0)GO TO 1
       D=2.44  
       IF(RN(L+6).GE.20.)D=-D 
CC     IF(JK.LT.0)D=-D   
       E=ABS(RN(L+4))    
C DIDN'T WE DO THIS BEFORE??  
       IF(E.GE.80.0.AND.E.LT.180.)D=D*.6*RSTFAC(J2)    
       RDD=RDD+D 
1      IF(IZ.GT.0)GO TO 88    
3      RJQ(NX)=RDD   
       IF(R13.GE.0)GO TO 11   
CC     JT=1    
       RIS=RN(L+4)  
       IF(R13.NE.-1.)GO TO 12 
       A0=2.   
       IF(R7.LT.0)A0=-A0 
       A0=A0+RIS    
       GO TO 80
12     RIZ=RN(L+8)  
       IF(RIZ.EQ.999.)RIZ=0   
       RIZ=RIZ+8.   
	NX=RN(L+7)
	A0=MOD(NX,10)
       IF(A0.NE.0)A0=(A0-1.)*1.8    
C  *SPACE FOR EACH TAIL. 
13     A0=A0+RIZ    
       IF(JK.GE.2)A0=-A0 
C JK =2 =STEMS DOWN
       A0=A0+RIS    
C JT CAN BE 2(R4) OR 3(R5)
80     RJQ(JT)=A0   
11     IF(JA.EQ.6)GO TO 861   
       IF(JA.EQ.5)GO TO 361   
       RETURN  
461    IF(JA.EQ.6)GO TO 277   
       IF(JA.NE.5)GO TO 361   
C JUMP IF NOT SLUR  
277    IF(PLACE(R6).LT.0)GO TO 561 
CC     R6=RDD   
C ??????? 
       IZ=4    
C TO PUT RDD INTO R6 LATER
       GO TO 2 
861    IF(J7.GE.0)GO TO 361   
        IF(R9.LE.0)GO TO 661  
561    IF(PLACE(R9).LT.0)GO TO 661 
       IF(J7.LT.0)GO TO 761   
C  J7=NEG MEANS TREMOLO  
       IF(R8.NE.0)GO TO 761   
       IF(R10.EQ.0)GO TO 361  
761     IZ=7   
C TO PUT RDD INTO R9 LATER
        GO TO 2
C  R8=0, R10=0 MEANS R9 IS NUMBER OUTSIDE OF BEAM.
661    IF(JA.EQ.5)GO TO 361   
       IF(J10.EQ.0)GO TO 361  
       IF(PLACE(R8).LT.0)GO TO 361 
C  HOMES INNER PARTIAL BEAMS  
       IZ=6    
C TO PUT RDD INTO R8 LATER
       GO TO 2 
88     RJQ(IZ)=RDD   
C  PUT A INTO RIGHT PARAM.    
361    CONTINUE
       END
     
	FUNCTION PLACE(X)
 	COMMON R2,JA,CENTR,J2,RJQ(8),R11
	1 /RMOD/RMODE2,RSET4,IBEAM,NOSET,STEM,STUP,NTC,ENDP,RAD,RDD
	PLACE=R11-ABS(RDD-X)
	END